home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / Plurals / Modules / lib.em < prev    next >
Lisp/Scheme  |  1992-06-03  |  2KB  |  56 lines
  1. (defmodule lib (ppl ppl-ll standard0 plural) ()
  2.  
  3.   (depfun null (o) (if o () t))
  4.  
  5.   (depfun list-length (l) (if (null l) 0 (+ 1 (list-length (cdr l)))))
  6.  
  7.   (depfun list-ref (l i) (if (null l) ()
  8.                (if (eq i 0) (car l)
  9.                  (list-ref (cdr l) (- i 1)))))
  10.  
  11.   (depfun tail (l)
  12.     (if (null l) ()
  13.       (if (null (cdr l)) l (tail (cdr l)))))
  14.  
  15.   (depfun append (front rest)
  16.     (let ((front-end (tail front)))
  17.       (if (null front-end) rest
  18.     (progn
  19.       ((setter cdr) front-end rest)
  20.       front))))
  21.  
  22.   (depfun convert-internal (d v i)
  23.       (if (null d) v
  24.         (progn
  25.           (convert-internal (cdr d) v (- i 1))
  26.           ((setter vector-ref) v i (car d)) v)))
  27.  
  28.   (depfun convert (l)
  29.       (let ((l-l (list-length l)))
  30.         (convert-internal l (make-vector l-l) (- l-l 1))))
  31.  
  32.   (defun any (l)
  33.     ; returns t if l contains at leats 1 non-nil element
  34.     (if l (if (car l) t (any (cdr l))) ()))
  35.  
  36.   (defun args-left-p (args)
  37.     ; each arg is a plural containing a list, if any of these lists contains
  38.     ; a null then there are no more args for parallel mapcar
  39. ;    (mapcar (lambda (o) (format t "\n ~a" (allocate-xec The-Context o))) args)
  40. ;    (format t "\n")
  41.     (not (any (mapcar (lambda (o) (let ((status (mp-if The-Context
  42.                                (mp-not The-Context o))))
  43.                     (mp-fi The-Context) status)) args))))
  44.   (defun l-mapcar (fn args)
  45.     (if (not (args-left-p args)) (mp-bang The-Context ())
  46.       (mp-cons The-Context (apply fn (mapcar PF-car args))
  47.            (l-mapcar fn (mapcar PF-cdr args)))))
  48.  
  49.   (defun PF-mapcar (fn . args) (l-mapcar fn args))
  50.   
  51.   (add-pfun 'mapcar 'PF-mapcar '(fn . args))
  52.   (export PF-mapcar)
  53.   
  54. )
  55.  
  56.